home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume10 / ifp / part05 < prev    next >
Encoding:
Text File  |  1987-07-06  |  58.5 KB  |  2,288 lines
  1. Path: uunet!rs
  2. From: rs@uunet.UU.NET (Rich Salz)
  3. Newsgroups: comp.sources.unix
  4. Subject: v10i038: Interpreted Functional Programming lanuage, Part 05/07
  5. Message-ID: <578@uunet.UU.NET>
  6. Date: 7 Jul 87 23:22:51 GMT
  7. Organization: UUNET Communications Services, Arlington, VA
  8. Lines: 2277
  9. Approved: rs@uunet.uu.net
  10.  
  11. Mod.sources: Volume 10, Number 38
  12. Submitted by: robison@b.cs.uiuc.edu (Arch Robison)
  13. Archive-name: ifp/Part05
  14.  
  15. #! /bin/sh
  16. # This is a shell archive, meaning:
  17. # 1. Remove everything above the #! /bin/sh line.
  18. # 2. Save the resulting text in a file.
  19. # 3. Execute the file with /bin/sh.
  20. # The following files will be created:
  21. #    interp/cache.c
  22. #    interp/cache.h
  23. #    interp/command.c
  24. #    interp/convert.c
  25. #    interp/debug.c
  26. #    interp/dos.s
  27. #    interp/error.c
  28. #    interp/except.c
  29. #    interp/file.c
  30. #    interp/forms.c
  31. export PATH; PATH=/bin:$PATH
  32. mkdir interp
  33. if test -f 'interp/cache.c'
  34. then
  35.     echo shar: over-writing existing file "'interp/cache.c'"
  36. fi
  37. cat << \SHAR_EOF > 'interp/cache.c'
  38.  
  39. /****** cache.c *******************************************************/
  40. /**                                                                  **/
  41. /**                    University of Illinois                        **/
  42. /**                                                                  **/
  43. /**                Department of Computer Science                    **/
  44. /**                                                                  **/
  45. /**   Tool: IFP                         Version: 0.5                 **/
  46. /**                                                                  **/
  47. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  48. /**                                                                  **/
  49. /**   Revised by: Arch D. Robison       Date: July 29, 1986          **/
  50. /**                                                                  **/
  51. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  52. /**                            Prof. W. J. Kubitz                    **/
  53. /**                                                                  **/
  54. /**                                                                  **/
  55. /**------------------------------------------------------------------**/
  56. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  57. /**                       All Rights Reserved.                       **/
  58. /**********************************************************************/
  59.  
  60. /*
  61.  * NOTE: Function HashOb assumes a FPfloat is either 1x or 2x the size
  62.  *      of a long.
  63.  */
  64.  
  65. #include "struct.h"
  66. #include "cache.h"
  67. #include <stdio.h>
  68.  
  69. #if ECACHE
  70.  
  71. CacheEntry ECache[CACHE_SIZE];
  72.  
  73. CacheRec Cache [4] = {
  74.    {0,0,0,0,"Prim"},
  75.    {0,0,0,0,"User"},
  76.    {0,0,0,0,"PFO"},
  77.    {0,0,0,0,"Total"},
  78. };
  79.  
  80. #define ArraySize(A) (sizeof(A)/sizeof(A[0]))
  81.  
  82. /*
  83.  * Print the cache statistics on stdout and clear the cache statistics tallies.
  84.  */
  85. void ShowCache ()
  86.    {
  87.       CacheRec *C,*T= &Cache[CacheTotal];
  88.       CacheEntry *E;
  89.       int Tally=0;
  90.       
  91.       for (E=ECache; E < ArrayEnd(ECache); E++) 
  92.      if (E->EC_Fun != NULL) Tally++;
  93.  
  94.       printf ("%d/%d = %g full cache\n", 
  95.           Tally, ArraySize (ECache), (double) Tally / ArraySize (ECache));
  96.  
  97.       T->Enable = 0;
  98.       for (C= &Cache[0]; C<&Cache[4]; C++) {
  99.      if (C->Enable) {
  100.         Cache[CacheTotal].Enable=1;
  101.         printf ("%s:\t%d hits in %d looks = %g%% hit rate [%d evictions]\n",
  102.             C->Name,C->Hits,C->Looks,
  103.             100.0 * C->Hits / (C->Looks ? C->Looks : 1), C->Evictions);
  104.         T->Hits  += C->Hits; 
  105.         T->Looks += C->Looks; 
  106.         T->Evictions += C->Evictions; 
  107.         C->Hits = C->Looks = C->Evictions = 0;
  108.      }
  109.       }
  110.       if (!T->Enable) printf ("The cache is disabled\n");
  111.    }
  112.  
  113. #if DEBUG
  114. void PrintCache (Message,E)
  115.    char *Message;
  116.    CacheEntry *E;
  117.    {
  118.       printf ("ECache %s ",Message);    OutObject (&E->EC_In);
  119.       printf (" : ");            OutNode   (E->EC_Fun);
  120.       printf (" -> ");            OutObject (&E->EC_Out);
  121.       printf ("\n");
  122.    }
  123. #endif /* DEBUG */
  124.  
  125. /*
  126.  * HashOb
  127.  *
  128.  * HashOb computes an integer function (hash code) of an object.
  129.  *
  130.  * Input
  131.  *    X = object
  132.  * Output
  133.  *     result = hash code
  134.  */
  135. int HashOb (X)
  136.    ObjectPtr X;
  137.    {
  138.       register long H;
  139.       register ListPtr P;
  140.  
  141.       switch (X->Tag) {
  142.       case BOTTOM:  H = 2305;                       break;
  143.       case BOOLEAN: H = X->Bool;                    break;
  144.       case INT:     H = X->Int * 9;                 break;
  145.       case FLOAT:
  146.          if (sizeof (FPfloat) == 2*sizeof (long))
  147.         H = ((long *)&(X->Float))[0] + ((long *)&(X->Float))[1];
  148.          else if (sizeof (FPfloat) == sizeof (long))
  149.         H = ((long *)&(X->Float))[0];
  150.          else
  151.         fprintf (stderr,"HashOb: can't hash floats on this machine!\n");
  152.          break;
  153.       case STRING:  H = (long) X->String;           break;
  154.       case LIST:
  155.          H = 5298;
  156.          for (P=X->List; P!=NULL; P=P->Next)
  157.         H = H * 0x1243 + HashOb (&P->Val);
  158.          break;
  159.       case NODE:    H = (long) X->Node * 5;         break;
  160.       case CODE:    H = (long) X->Code.CodePtr +
  161.                 (long) X->Code.CodeParam;   break;
  162.       default:
  163.          fprintf (stderr,"HashOb: invalid tag (%d)\n",X->Tag);
  164.          break;
  165.       }
  166.       return H;
  167.    }
  168.  
  169. ClearCache ()            /* Clear all entries from the cache. */
  170.    {
  171.       CacheEntry *C;
  172.  
  173.       for (C=ECache+CACHE_SIZE; --C >= ECache; ) {
  174.      RepTag (&C->EC_In, BOTTOM);
  175.      C->EC_Fun = NULL;
  176.      RepTag (&C->EC_Out,BOTTOM);
  177.       }
  178.    }
  179.  
  180. InitCache ()            /* Initialize the cache */
  181.    {
  182.       register CacheEntry *E;
  183.       CacheRec *C;
  184.  
  185.       printf (" (cache");
  186.       for (C=Cache; C<&Cache[3]; C++)
  187.      if (C->Enable) printf (" %s",C->Name);
  188.       printf (")");
  189.  
  190.       for (E=ECache+CACHE_SIZE; --E >= ECache; ) {
  191.      E->EC_In. Tag = BOTTOM;
  192.      E->EC_Fun = NULL;
  193.      E->EC_Out.Tag = BOTTOM;
  194.       }
  195.    }
  196.  
  197. #endif /* ECACHE */
  198.  
  199. SHAR_EOF
  200. if test -f 'interp/cache.h'
  201. then
  202.     echo shar: over-writing existing file "'interp/cache.h'"
  203. fi
  204. cat << \SHAR_EOF > 'interp/cache.h'
  205.  
  206. /****** cache.h *******************************************************/
  207. /**                                                                  **/
  208. /**                    University of Illinois                        **/
  209. /**                                                                  **/
  210. /**                Department of Computer Science                    **/
  211. /**                                                                  **/
  212. /**   Tool: IFP                         Version: 0.1                 **/
  213. /**                                                                  **/
  214. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  215. /**                                                                  **/
  216. /**   Revised by: Arch D. Robison       Date: July 29, 1986          **/
  217. /**                                                                  **/
  218. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  219. /**                            Prof. W. J. Kubitz                    **/
  220. /**                                                                  **/
  221. /**                                                                  **/
  222. /**------------------------------------------------------------------**/
  223. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  224. /**                       All Rights Reserved.                       **/
  225. /**********************************************************************/
  226.  
  227. #define ECACHE 0    /* Implement expression cache if defined */
  228.  
  229. #if ECACHE
  230.  
  231. /*
  232.  * The expression cache can be turned on selectively for expressions with
  233.  * primitive functions, user-defined functions, or PFOs.
  234.  *
  235.  * Cache[i].Enable = 0/1 to turn off/on cache for expression type i in [0..2]. 
  236.  */
  237. #define CachePrim  0
  238. #define CacheUser  1
  239. #define CachePFO   2
  240. #define CacheTotal 3
  241.  
  242. typedef struct {
  243.    boolean Enable;
  244.    int Looks;        /* Number of looks into cache */
  245.    int Hits;        /* Number of successful looks */
  246.    int Evictions;    /* Number of evictions          */
  247.    char *Name;        /* "Prim", "User", "PFO", etc.*/    
  248. } CacheRec;
  249.  
  250. extern CacheRec Cache[];
  251.  
  252. #if DEBUG
  253. extern void PrintCache ();
  254. #endif
  255.  
  256. /*
  257.  * The expression cache is implemented as a hash table.  It
  258.  * associates outputs with <input,function> pairs.
  259.  */
  260.  
  261. #define CACHE_SIZE 1024 /* Must be power of 2 */
  262.  
  263. /*
  264.  * EC_Fun.Tag = BOTTOM iff that cache entry is empty
  265.  */
  266. typedef struct {
  267.    Object EC_In, EC_Out;
  268.    NodePtr EC_Fun;
  269. } CacheEntry;
  270.  
  271. extern CacheEntry ECache[];
  272. extern int HashOb ();
  273. extern void ShowCache (); /* Show cache statistics                */
  274.  
  275. /*
  276.  * CheckCache
  277.  *
  278.  * Parameter
  279.  *      T = &Cache[i] where i is type of function to be cached.
  280.  *    A = call to "apply" with appropriate arguments.
  281.  */
  282. #define CheckCache(T,A)                            \
  283.    if ((T)->Enable) {                            \
  284.       CacheEntry *C;                            \
  285.       extern int TraceDepth;                        \
  286.                                     \
  287.       (T)->Looks++;                            \
  288.       C = &ECache [(HashOb(InOut) + (long) F->Node) * 0x9B & CACHE_SIZE-1]; \
  289.       if (ApplyFun == C->EC_Fun && ObEqual (InOut,&C->EC_In)) {        \
  290.      if (Debug & DebugCache) PrintCache ("Hit!",C);            \
  291.      (T)->Hits++;                            \
  292.      if (Trace|SaveTrace) printf ("IBID\n");            \
  293.      RepObject (InOut,&C->EC_Out);                    \
  294.       } else {                                \
  295.      if (C->EC_Fun != NULL) {                    \
  296.         (T)->Evictions++;                        \
  297.         if (Debug & DebugCache) PrintCache ("Evict",C);        \
  298.      }                                \
  299.      C->EC_Fun = NULL;                        \
  300.      RepObject (&C->EC_In,InOut);                    \
  301.      {A;}                                \
  302.      C->EC_Fun = F->Node;                        \
  303.      RepObject (&C->EC_Out,InOut);                    \
  304.      if (Debug & DebugCache) PrintCache ("Load",C);            \
  305.       }                                    \
  306.    } else {A;}
  307.  
  308. #else
  309.  
  310. #define CheckCache(T,A) {A;}
  311. #define ClearCache()
  312.  
  313. #endif
  314.  
  315. /***************************** end of cache.h ****************************/
  316.  
  317. SHAR_EOF
  318. if test -f 'interp/command.c'
  319. then
  320.     echo shar: over-writing existing file "'interp/command.c'"
  321. fi
  322. cat << \SHAR_EOF > 'interp/command.c'
  323.  
  324. /****** command.c *****************************************************/
  325. /**                                                                  **/
  326. /**                    University of Illinois                        **/
  327. /**                                                                  **/
  328. /**                Department of Computer Science                    **/
  329. /**                                                                  **/
  330. /**   Tool: IFP                         Version: 0.5                 **/
  331. /**                                                                  **/
  332. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  333. /**                                                                  **/
  334. /**   Revised by: Arch D. Robison       Date:  Jan 28, 1987          **/
  335. /**                                                                  **/
  336. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  337. /**                            Prof. W. J. Kubitz                    **/
  338. /**                                                                  **/
  339. /**                                                                  **/
  340. /**------------------------------------------------------------------**/
  341. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  342. /**                       All Rights Reserved.                       **/
  343. /**********************************************************************/
  344.  
  345. /*************************** Command Interpreter **************************/
  346.  
  347.  
  348. #include <stdio.h>
  349. #include <errno.h>
  350. #include "struct.h"
  351. #include "node.h"
  352. #include "umax.h"
  353. #include "inob.h"
  354. #include "cache.h"
  355. #include "stats.h"
  356.  
  357. #if OPSYS==UNIX
  358. #include <strings.h>
  359. #include <sys/wait.h>
  360. #endif
  361.  
  362. #if OPSYS==MSDOS
  363. #include "/usr/include/dos/spawn.h"     /* Full name so lint can find it */
  364. #include "/usr/include/dos/string.h"
  365. #endif
  366.  
  367. extern char EditorPath [],*EdCommand;
  368. extern char *getenv ();
  369.  
  370. extern boolean RefCheck ();        /* from apply.c */
  371.  
  372. #if OPSYS==UNIX
  373. extern fork (),execl ();
  374. #endif
  375.  
  376. InDesc UserIn;
  377.  
  378. /*
  379.  * ReadNode
  380.  */
  381. private NodePtr ReadNode (U)
  382.    InDesc *U;
  383.    {
  384.       Object S;
  385.  
  386.       if (!InNode (U,&S,NIL)) return NULL;
  387.       LinkPath (&S,DEF);
  388.       if (S.Tag == NODE) return S.Node;
  389.       else {
  390.      printf ("Error: ");
  391.      OutString (S.String);
  392.      printf (" not defined\n");
  393.      return NULL;
  394.       }
  395.    }
  396.  
  397. #if REFCHECK
  398. /*
  399.  * ShowRefCheck
  400.  */
  401. void ShowRefCheck ()
  402.    {
  403.       Object F;
  404.       register InDesc *U;
  405.  
  406.       U = &UserIn;
  407.       F.Tag = BOTTOM;
  408.  
  409.       (void) InComp (U,&F,NIL);
  410.       (void) RefCheck ((NodePtr) NULL,&F);
  411.       RepTag (&F,BOTTOM);
  412.    }
  413. #endif
  414.  
  415.  
  416. /*
  417.  * ShowApply
  418.  */
  419. private void ShowApply (OutGraph)
  420.    int OutGraph;
  421.    {
  422.       Object X,F;
  423.       register InDesc *U;
  424.  
  425.       U = &UserIn;
  426.       X.Tag = BOTTOM;
  427.       F.Tag = BOTTOM;
  428.       if (InObject (U,&X)) {
  429.  
  430.      if (!IsTok (U,":")) (void) InError (U,"colon expected");
  431.      else {
  432.         (void) InComp (U,&F,NIL);
  433.         if (Debug & DebugFile) {
  434.            printf ("Object = "); OutObject (&X); printf ("\n");
  435.            printf ("Function = "); OutFun (&F,MaxInt); printf ("\n");
  436.         }
  437.  
  438.         if (*U->InPtr) (void) InError (U,"extra character on line");
  439.         else {
  440.            U->InPtr++;
  441.               ClearCache ();
  442.               Apply (&X,&F);
  443. #ifdef GRAPHICS
  444.               if (OutGraph) DrawObject (&X);
  445.               else OutPretty (&X,0);
  446. #else
  447.               OutPretty (&X,0);
  448.               printf ("\n");
  449. #endif
  450.         }
  451.      }
  452.       }
  453.       RepTag (&X,BOTTOM);
  454.       RepTag (&F,BOTTOM);
  455.    }
  456.  
  457. /*
  458.  * ExecFile
  459.  *
  460.  * Execute a file
  461.  *
  462.  * Input
  463.  *      Prog = program to be executed
  464.  *      Arg  = argument string
  465.  */
  466. void ExecFile (Prog,Arg)
  467.    char *Prog,*Arg;
  468.    {
  469.       if (Debug & DebugFile) printf ("ExecFile (%s,%s)\n",Prog,Arg);
  470. #if OPSYS==UNIX
  471.       if (fork ()) (void) wait ((union wait *)NULL);
  472.       else {
  473.      if (Debug & DebugFile) printf ("prepare to flush\n");
  474.      (void) fflush (stdout);
  475.      execl (Prog,Prog,Arg,(char *)NULL);
  476.      perror (Prog);
  477.      exit (1);
  478.       }
  479. #endif
  480. #if OPSYS==MSDOS
  481.       if (spawnl (P_WAIT,Prog,Prog,Arg,(char *)NULL)) perror (Prog);
  482. #endif
  483.    }
  484.  
  485. void ExecEdit (FileName)
  486.    char *FileName;
  487.    {
  488.       if (Debug & DebugFile) printf ("ExecEdit (%s)\n",FileName);
  489. #if OPSYS==UNIX
  490.       ExecFile (EditorPath,FileName);
  491. #endif
  492. #if OPSYS==MSDOS
  493.       {
  494.      extern char *PathSplit ();
  495.      char *T;
  496.      T = PathSplit (FileName);
  497.      if (T != NULL) ExecFile (EditorPath,T);
  498.       }
  499. #endif
  500.    }
  501.  
  502. /*
  503.  * EditRm
  504.  *
  505.  * Action depends on ``Edit'' flag:
  506.  *
  507.  * Edit
  508.  *     Apply the user's editor to a function or import file.  If a function,
  509.  *     delete the function definition from memory. If %IMPORT file, reread it.
  510.  *
  511.  * !Edit
  512.  *     Remove a function definition or %IMPORT file.
  513.  */
  514. private void EditRm (U,Edit)
  515.    register InDesc *U;
  516.    boolean Edit;
  517.    {
  518.       Object N;
  519.       char Buf[MAXPATH+1];
  520.       static char *Import = "%IMPORT";
  521.    
  522.       if (Debug & DebugFile) printf ("EditRm (%s,%d)\n",U->InPtr,Edit);
  523.  
  524.       if (IsTok (U,Import)) {
  525.  
  526.      if (Edit) ExecFile (EditorPath,Import);
  527.      else 
  528.         if (unlink (Import)) perror (Import);
  529.      DelImport (U->InDefMod);
  530.      ReadImport (U->InDefMod);
  531.  
  532.       } else {
  533.  
  534.      N.Tag = BOTTOM;
  535.      (void) InNode (U,&N,NIL);
  536.      LinkPath (&N,DEF);
  537.  
  538.      /* Kill old source code definition */
  539.      if (N.Tag == NODE)
  540.         switch (N.Node->NodeType) {
  541.            case DEF:
  542.           RepTag (&N.Node->NodeData.NodeDef.DefCode,BOTTOM);
  543.           break;
  544.            case MODULE:
  545.           break;
  546.         }
  547.  
  548.      FormPath (&N,Buf,&Buf[MAXPATH]);
  549.      RepTag (&N,BOTTOM);
  550.      if (Edit) ExecEdit (Buf);
  551.      else
  552.         if (unlink (Buf)) perror (Buf);
  553.       }
  554.    }
  555.  
  556. #if OPSYS==UNIX
  557. /*
  558.  * Shell
  559.  *
  560.  * Execute a shell command
  561.  */
  562. void Shell (U)
  563.    register InDesc *U;
  564.    {
  565.       if (Debug & DebugFile) printf ("Shell: '%s'\n",U->InPtr);
  566.       if (fork ()) (void) wait ((union wait *)NULL);
  567.       else {
  568.      (void) fflush (stdout);
  569.      execl ("/bin/sh","sh","-c",U->InPtr,(char *)NULL);
  570.       }
  571.    }
  572. #endif
  573. #if OPSYS==MSDOS
  574. /*
  575.  * ChDirToCWD
  576.  *
  577.  * Set DOS current working directory to IFP current working directory.
  578.  *
  579.  * This procedure is a necessary KLUDGE because the current directory
  580.  * cache mechanism changes the current working directory all over the place.
  581.  */
  582. void ChDirToCWD ()
  583.    {
  584.       char Buf[MAXPATH];
  585.       extern char *FormNPath ();
  586.  
  587.       (void) FormPath (CurWorkDir,Buf,&Buf[MAXPATH]);
  588.       chdir (Buf);
  589.    }
  590.  
  591. /*
  592.  * Directory
  593.  *
  594.  * Show the current directory
  595.  */
  596. void Directory (U)
  597.    register InDesc *U;
  598.    {
  599.       extern char DirPath[];
  600.  
  601.       ChDirToCWD ();
  602.       ExecFile (DirPath,U->InPtr);
  603.    }
  604. #endif
  605.  
  606. /*
  607.  * SetDepth
  608.  *
  609.  * Set function printing depth used for printing.
  610.  */
  611. SetDepth (U)
  612.    register InDesc *U;
  613.    {
  614.       Object X;
  615.       FPint N;
  616.       extern int TraceDepth;
  617.  
  618.       X.Tag = BOTTOM;
  619.       (void) InObject (U,&X);
  620.       if (GetFPInt (&X,&N) || N < 0 || N > MaxInt)
  621.      printf ("Error: depth must be integer in range 0..%d\n",MaxInt);
  622.       else TraceDepth = N;
  623.    }
  624.  
  625.  
  626. /*
  627.  * SetTrace
  628.  *
  629.  * Set or reset function trace flags.
  630.  */
  631. private void SetTrace (U)
  632.    register InDesc *U;
  633.    {
  634.       NodePtr N;
  635.       int T;       /* phone home */
  636.  
  637.       if (IsTok (U,"on")) T=1;
  638.       else if (IsTok (U,"off")) T=0;
  639.       else {
  640.      printf ("trace [on|off] f1 f2 f3 ... \n");
  641.      return;
  642.       }
  643.       while (*U->InPtr) {
  644.      N = ReadNode (U);
  645.      if (N != NULL) {
  646.         if (T) N->NodeData.NodeDef.DefFlags |= TRACE;
  647.         else   N->NodeData.NodeDef.DefFlags &= ~TRACE;
  648.      } else break;
  649.       }
  650.    }
  651.  
  652. #if DUMP
  653. extern void DumpNode();
  654. #endif
  655.  
  656. void UserLoop ()
  657.    {
  658.       register InDesc *U;
  659.       int N;
  660.  
  661.       U = &UserIn;
  662.       while (1) {
  663.      extern char FPprompt [], *gets();
  664.      extern void ResetExcept();
  665. #if OPSYS==MSDOS
  666.      extern char CWDCache [];
  667.      CWDCache [0] = '\0';        /* Clear current directory cache */
  668. #endif
  669.      ResetExcept ();
  670.      if (Debug & DebugAlloc) {
  671.         extern ListPtr FreeList;
  672.         printf ("length (FreeList) = %ld\n",ListLength (FreeList));
  673.      }
  674.      printf ("%s",FPprompt);
  675.      (void) fflush (stdout);
  676.      InitIn (U,CurWorkDir,stdin,-1);
  677.  
  678.      /* Copy prompt so that error message '^' will point correctly. */
  679.      U->InPtr += N = strlen (strcpy (U->InPtr,FPprompt));
  680.      (void) fgets (U->InPtr, INBUFSIZE-N, stdin);
  681.  
  682.      if (!*U->InPtr || IsTok (U,"exit")) {
  683. #if OPSYS==MSDOS
  684.         ChDirToCWD ();
  685. #endif
  686.         return;
  687.      }
  688.      else if (IsTok (U,"depth")) SetDepth (U);
  689.      else if (IsTok (U,"show")) ShowApply (0);
  690. #if HYPERCUBE
  691.      else if (IsTok (U,"send")) {
  692.         Object X;
  693.         ForkFP ();
  694.         InObject (U,&X); 
  695.         OutBinObject (&X);
  696.      }
  697. #endif
  698. #if COMPILE
  699.      else if (CompilerFlag && IsTok (U,"c")) Compile (U);
  700. #endif
  701. #if REFCHECK
  702.      else if (IsTok (U,"check")) ShowRefCheck ();
  703. #endif
  704. #if ECACHE
  705.      else if (IsTok (U,"cache")) ShowCache ();
  706. #endif
  707. #if STATS
  708.      else if (IsTok (U,"stats")) ShowStats ();
  709. #endif
  710.      else if (IsTok (U,"trace")) SetTrace (U);
  711.      else if (IsTok (U,EdCommand)) EditRm (U,1);
  712. #if DUMP
  713.      else if (IsTok (U,"dump")) DumpNode (CurWorkDir,0);
  714. #endif
  715. #ifdef GRAPHICS
  716.      else if (IsTok (U,"graph")) ShowApply (1);
  717. #endif
  718.      /* else if (IsTok (U,"test")) Test (U); */
  719. #if OPSYS==UNIX
  720.      else if (IsTok (U,"rm")) EditRm (U,0);
  721.      else Shell (U);
  722. #endif
  723. #if OPSYS==MSDOS
  724.      else if (IsTok (U,"del")) EditRm (U,0);
  725.      else if (IsTok (U,"dir")) Directory (U);
  726. #endif
  727. #if OPSYS==MSDOS || OPSYS==CTSS
  728.      else printf ("Unknown command: %s\n",U->InPtr);
  729. #endif
  730.       }
  731.    }
  732.  
  733.  
  734. /************************** end of command.c **************************/
  735. SHAR_EOF
  736. if test -f 'interp/convert.c'
  737. then
  738.     echo shar: over-writing existing file "'interp/convert.c'"
  739. fi
  740. cat << \SHAR_EOF > 'interp/convert.c'
  741.  
  742. /****** convert.c *****************************************************/
  743. /**                                                                  **/
  744. /**                    University of Illinois                        **/
  745. /**                                                                  **/
  746. /**                Department of Computer Science                    **/
  747. /**                                                                  **/
  748. /**   Tool: IFP                         Version: 0.5                 **/
  749. /**                                                                  **/
  750. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  751. /**                                                                  **/
  752. /**   Revised by: Arch D. Robison       Date:  July 2, 1986          **/
  753. /**                                                                  **/
  754. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  755. /**                            Prof. W. J. Kubitz                    **/
  756. /**                                                                  **/
  757. /**                                                                  **/
  758. /**------------------------------------------------------------------**/
  759. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  760. /**                       All Rights Reserved.                       **/
  761. /**********************************************************************/
  762.  
  763. /* Type conversion functions */
  764.  
  765. #include <stdio.h>
  766. #include <ctype.h>
  767. #include "struct.h"
  768. #include "string.h"
  769. #include <math.h>
  770.  
  771. #define BUFSIZE 80 /* Maximum length of numeric string */
  772.  
  773. /*
  774.  * GetFPInt
  775.  *
  776.  * Get value of FP integer.
  777.  *
  778.  * Input
  779.  *    X = FP object
  780.  *
  781.  * Output
  782.  *    *K = FPint value of X
  783.  *    result = error code: 0 = X was converted to integer *K
  784.  *                         1 = X not an integer
  785.  *                         2 = X too big
  786.  */
  787. int GetFPInt (X,K)
  788.    ObjectPtr X;
  789.    FPint *K;
  790.    {
  791.       switch (X->Tag) {
  792.      default: return 1;
  793.      case INT: *K = X->Int; return 0;
  794.      case FLOAT: {
  795.         double F;
  796.         F = X->Float;
  797.         if (fabs (F) <= (double) FPMaxInt) {
  798.            *K = (FPint) F;
  799.            F -= (double) *K;
  800.            return fabs (F) >= CompTol;
  801.         } else return 2;
  802.      }
  803.       }
  804.    }
  805.  
  806. #if OPSYS==CTSS
  807. /*
  808.  * IsFloat
  809.  *
  810.  * Determine if a string represents floating point number as defined
  811.  * by C's atof function.  This function is necessary for the CRAY
  812.  * since there is a bug in sscanf for the CRAY.
  813.  *
  814.  * Input
  815.  *    S = string
  816.  *
  817.  * Output
  818.  *    result = true iff string represents number.
  819.  */
  820. int IsFloat (S)
  821.    register char *S;
  822.    {
  823.       int Digits = 0;
  824.       if (*S == '+' || *S == '-') S++;
  825.       while (isdigit (*S)) {
  826.      S++;
  827.      Digits++;
  828.       }
  829.       if (*S == '.') 
  830.      while (isdigit (*++S)) Digits++;
  831.       if (!Digits) return 0;
  832.       if (*S == '\0') return 1;
  833.       if (*S++ != 'e') return 0;
  834.       if (*S == '+' || *S == '-') S++;
  835.       while (isdigit (*S)) S++;
  836.       return *S == '\0';
  837.    }
  838. #endif /* OPSYS==CTSS */
  839.  
  840. /*
  841.  * StrToFloat
  842.  *
  843.  * Convert object to float representation if possible.
  844.  *
  845.  * Input
  846.  *    *X = object
  847.  *
  848.  * Output
  849.  *    *X = new representation of object
  850.  *    result = 1 if *X is float, 0 otherwise.
  851.  */
  852. boolean StrToFloat (X)
  853.    ObjectPtr X;
  854.    {
  855.       CharPtr U;
  856.       char Buf[BUFSIZE+1];
  857.       double F;
  858. #if OPSYS!=CTSS
  859.       char Term;
  860. #endif
  861.       CPInit (&U,&X->String);
  862.       (void) CPRead (&U,Buf,BUFSIZE);
  863.  
  864. #if OPSYS==CTSS
  865.       if (!IsFloat (Buf)) return 0;
  866.       F = atof (Buf);
  867. #else 
  868.       Buf [strlen (Buf)] = '\1';
  869.       if (2 != sscanf (Buf,"%lf%c",&F,&Term) || Term != '\1') return 0;
  870. #endif
  871.       RepTag (X,FLOAT);
  872.       X->Float = (FPfloat) F;
  873.       return 1;
  874.    }
  875.  
  876. /*
  877.  * GetDouble
  878.  *
  879.  * Output
  880.  *    result = 0 if *D is valid, 1 otherwise.
  881.  */
  882. int GetDouble (X,D)
  883.    ObjectPtr X;
  884.    double *D;
  885.    {
  886.      switch (X->Tag) {
  887.     case INT:   *D = X->Int; return 0;
  888.     case FLOAT: *D = X->Float; return 0;
  889.     default: return 1;
  890.       }
  891.    }
  892.  
  893.  
  894. /****************************** end of convert.c *****************************/
  895. SHAR_EOF
  896. if test -f 'interp/debug.c'
  897. then
  898.     echo shar: over-writing existing file "'interp/debug.c'"
  899. fi
  900. cat << \SHAR_EOF > 'interp/debug.c'
  901.  
  902. /****** debug.c *******************************************************/
  903. /**                                                                  **/
  904. /**                    University of Illinois                        **/
  905. /**                                                                  **/
  906. /**                Department of Computer Science                    **/
  907. /**                                                                  **/
  908. /**   Tool: IFP                         Version: 0.5                 **/
  909. /**                                                                  **/
  910. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  911. /**                                                                  **/
  912. /**   Revised by: Arch D. Robison       Date:   Dec 5, 1985          **/
  913. /**                                                                  **/
  914. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  915. /**                            Prof. W. J. Kubitz                    **/
  916. /**                                                                  **/
  917. /**                                                                  **/
  918. /**------------------------------------------------------------------**/
  919. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  920. /**                       All Rights Reserved.                       **/
  921. /**********************************************************************/
  922.  
  923.  
  924. #include <stdio.h>
  925. #include "struct.h"
  926. #include "string.h"
  927.  
  928. #if DEBUG
  929. int Debug = 0;     /* Print debugging statements if true */
  930. #endif
  931.  
  932. #if DUMP
  933. /*
  934.  * DumpNode
  935.  *
  936.  * Print out node N and all its decendants.
  937.  */
  938. void DumpNode (N,Indent)
  939.    register NodePtr N;
  940.    int Indent;
  941.    {
  942.       extern void OutIndent ();
  943.  
  944.       OutIndent (3*Indent);
  945.       if (N == NULL) printf ("DumpNode: N = NULL\n");
  946.       else {
  947.      OutString (N->NodeName);
  948.      switch (N->NodeType) {
  949.          case NEWNODE: printf ("(new) "); break;
  950.          case MODULE:
  951.         printf (" module\n");
  952.         for (N = N->NodeData.NodeMod.FirstChild; N!=NULL; N=N->NodeSib)
  953.            DumpNode (N,Indent+1);
  954.         break;
  955.          case DEF:
  956.            printf (" function");
  957.            if (N->NodeData.NodeDef.DefFlags & TRACE)
  958.           printf ("(trace) ");
  959.            OutObject (&N->NodeData.NodeDef.DefCode);
  960.            printf ("\n");
  961.            break;
  962.         case IMPORT:
  963.            printf (" import");
  964.            OutObject (&N->NodeData.NodeImp.ImpDef);
  965.            printf ("\n");
  966.            break;
  967.         default:
  968.            printf (" invalid NodeType (%x)\n",N->NodeType);
  969.            break;
  970.      }
  971.       }
  972.    }
  973.  
  974. #endif /* DUMP */
  975.  
  976.  
  977. /*************************** end of debug.c *********************************/
  978.  
  979. SHAR_EOF
  980. if test -f 'interp/dos.s'
  981. then
  982.     echo shar: over-writing existing file "'interp/dos.s'"
  983. fi
  984. cat << \SHAR_EOF > 'interp/dos.s'
  985. ;
  986. ;/****** dos.s**********************************************************/
  987. ;/**                                                                  **/
  988. ;/**                    University of Illinois                        **/
  989. ;/**                                                                  **/
  990. ;/**                Department of Computer Science                    **/
  991. ;/**                                                                  **/
  992. ;/**   Tool: IFP                         Version: 0.5                 **/
  993. ;/**                                                                  **/
  994. ;/**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  995. ;/**                                                                  **/
  996. ;/**   Revised by: Arch D. Robison       Date: Sept 28, 1985          **/
  997. ;/**                                                                  **/
  998. ;/**   Principal Investigators: Prof. R. H. Campbell                  **/
  999. ;/**                            Prof. W. J. Kubitz                    **/
  1000. ;/**                                                                  **/
  1001. ;/**                                                                  **/
  1002. ;/**------------------------------------------------------------------**/
  1003. ;/**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1004. ;/**                       All Rights Reserved.                       **/
  1005. ;/**********************************************************************/
  1006.  
  1007. ;/***** Assembly Language Routines for MS-DOS Implementation of IFP *****/
  1008.  
  1009. TITLE   dos
  1010.  
  1011. PUBLIC  _StackCheck, _SetCBrk
  1012. EXTRN    __chkstk:FAR
  1013.  
  1014. DOS_TEXT    SEGMENT  BYTE PUBLIC 'CODE'
  1015.  
  1016.  
  1017.     ASSUME  CS: DOS_TEXT
  1018. ;
  1019. ; SetCBrk
  1020. ;
  1021. ; Set control-C trapping for any DOS call.
  1022. ;
  1023. _SetCBrk     PROC FAR
  1024.         mov ax,3301H
  1025.         mov dl,01H
  1026.         int 21H
  1027.     ret    
  1028. _SetCBrk     ENDP
  1029.  
  1030. ;
  1031. ; StackCheck
  1032. ;
  1033. ; Check if there is enough room on the stack and check for break signal
  1034. ;
  1035. _StackCheck  PROC FAR
  1036.     push    bp
  1037.     mov    bp,sp
  1038.     mov    ax,64H
  1039.     call    FAR PTR __chkstk
  1040.         push es
  1041.         mov ah,2FH
  1042.         int 21H        ; Dummy GET_DTA to look for control-C
  1043.         pop es
  1044.     mov    sp,bp
  1045.     pop    bp
  1046.     ret    
  1047. _StackCheck  ENDP
  1048.  
  1049. DOS_TEXT    ENDS
  1050. END
  1051.  
  1052. ;/************************** end of dos.s **************************/
  1053. SHAR_EOF
  1054. if test -f 'interp/error.c'
  1055. then
  1056.     echo shar: over-writing existing file "'interp/error.c'"
  1057. fi
  1058. cat << \SHAR_EOF > 'interp/error.c'
  1059.  
  1060. /****** error.c *******************************************************/
  1061. /**                                                                  **/
  1062. /**                    University of Illinois                        **/
  1063. /**                                                                  **/
  1064. /**                Department of Computer Science                    **/
  1065. /**                                                                  **/
  1066. /**   Tool: IFP                         Version: 0.5                 **/
  1067. /**                                                                  **/
  1068. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1069. /**                                                                  **/
  1070. /**   Revised by: Arch D. Robison       Date:  Sept 8, 1986          **/
  1071. /**                                                                  **/
  1072. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1073. /**                            Prof. W. J. Kubitz                    **/
  1074. /**                                                                  **/
  1075. /**                                                                  **/
  1076. /**------------------------------------------------------------------**/
  1077. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1078. /**                       All Rights Reserved.                       **/
  1079. /**********************************************************************/
  1080.  
  1081. /************************ Error Message Routines **********************/
  1082.  
  1083. #include <stdio.h>
  1084. #include <ctype.h>
  1085. #include "struct.h"
  1086. #include "node.h"
  1087. #include "umax.h"
  1088. #include "inob.h"
  1089.  
  1090. /* Some common error messages */
  1091.  
  1092. char ArgNotSeq[] = "not a sequence",
  1093.      ArgSeqOb [] = "must be <sequence object>",
  1094.      ArgObSeq [] = "must be <object sequence>",
  1095.      ArgNull  [] = "empty sequence",
  1096.      ArgBottom[] = "argument is ?";         
  1097.  
  1098. /*
  1099.  * PrintErr
  1100.  *
  1101.  * Check if error message should be printed.  Error messages are not printed if
  1102.  * the argument is BOTTOM (in which case the error has already been noted), or
  1103.  * SysStop is set (the user has interrupted execution).
  1104.  *
  1105.  * Input
  1106.  *      InOut = argument to function                  
  1107.  *
  1108.  * Output
  1109.  *      result = true iff error message should be printed
  1110.  */
  1111. boolean PrintErr (InOut)
  1112.    ObjectPtr InOut;
  1113.    {
  1114.       return InOut->Tag != BOTTOM && !SysStop;
  1115.    }
  1116.  
  1117. /*
  1118.  * FormError
  1119.  *
  1120.  * Print PFO error message.
  1121.  *
  1122.  * Input
  1123.  *    InOut = input to form
  1124.  *    Message = error message
  1125.  *    N = offended form's index in FormTable
  1126.  *    P = form parameter list
  1127.  */
  1128. void FormError (InOut,Message,N,P)
  1129.    ObjectPtr InOut;              
  1130.    char *Message;
  1131.    int N;
  1132.    ListPtr P;
  1133.    {
  1134.       extern int TraceDepth;
  1135.  
  1136.       if (PrintErr (InOut)) {
  1137.          LineWait ();
  1138.      OutForm (FormTable[N].FormNode,P,TraceDepth);
  1139.      printf (": %s\n",Message);
  1140.      OutObject (InOut);
  1141.      printf ("\n");
  1142.          LineSignal ();
  1143.       }
  1144.       RepTag (InOut,BOTTOM);
  1145.    }
  1146.  
  1147. /*
  1148.  * FunError
  1149.  *
  1150.  * Print primitive function error.
  1151.  *
  1152.  * Input
  1153.  *      Message = error message
  1154.  *      InOut = offending object
  1155.  *      ApplyFun {global} = offended function
  1156.  */
  1157. void FunError (Message,InOut)
  1158.    char *Message;
  1159.    ObjectPtr InOut;
  1160.    {
  1161.       if (PrintErr (InOut)) {
  1162.          LineWait ();
  1163.      printf ("\n");
  1164.      OutNode (ApplyFun);
  1165.      printf (": %s\n",Message);
  1166.      OutObject (InOut);
  1167.      printf ("\n");
  1168.          LineSignal ();
  1169.       }
  1170.       RepTag (InOut,BOTTOM);
  1171.    }
  1172.  
  1173. /*
  1174.  * DefError
  1175.  *
  1176.  * Print definition error display.
  1177.  * 
  1178.  * Input
  1179.  *      Caller = calling node
  1180.  *      F = name of erroneous function
  1181.  *      Message = error message to print 
  1182.  */
  1183. void DefError (Caller,F,Message)
  1184.    NodePtr Caller;
  1185.    ObjectPtr F;
  1186.    char *Message;
  1187.    {
  1188.       LineWait ();
  1189.       OutObject (F);
  1190.       if (Caller != NULL) {
  1191.      printf (" (from ");
  1192.      OutNode (Caller);
  1193.      printf (")");
  1194.       }
  1195.       printf (": %s\n",Message);
  1196.       LineSignal ();
  1197.    }
  1198.  
  1199. /*
  1200.  * IntError
  1201.  *
  1202.  * Print internal error message.
  1203.  *
  1204.  * Input
  1205.  *    Message = error message
  1206.  */
  1207. void IntError (Message)
  1208.    char *Message;
  1209.    {
  1210.       fprintf (stderr,"\nINTERNAL ERROR (%s)\n",Message);
  1211.       if (Debug) abort (); 
  1212.       SysError = INTERNAL;
  1213.    }
  1214.  
  1215. /*
  1216.  * InError
  1217.  *
  1218.  * Print input error message.
  1219.  *
  1220.  * Input
  1221.  *    F = input descriptor
  1222.  *    Message = error message 
  1223.  *    
  1224.  * Output
  1225.  *    result = 0
  1226.  */
  1227. int InError (F,Message)
  1228.    InDesc *F;
  1229.    char *Message;
  1230.    {
  1231.       char *S;
  1232.  
  1233.       if (F->ComLevel > 0) Message = "open comment";
  1234.       printf ("Input error");
  1235.       if (F->InLineNum >= 0) {
  1236.      printf (" in ");
  1237.      OutNode (F->InDefMod); 
  1238.      printf ("/");
  1239.      if (F->InDefFun != NULL) OutString (F->InDefFun);
  1240.      else printf ("%IMPORT");
  1241.      printf (" on line %d:\n%s",F->InLineNum,F->InBuf);
  1242.          if (F->InBuf[strlen (F->InBuf)-1] != '\n') printf ("\n");
  1243.       } else printf ("\n");
  1244.       for (S=F->InBuf; S<F->InPtr; S++) 
  1245.      printf ("%c", isspace (*S) ? *S : ' ');
  1246.       printf ("^\n%s\n",Message);
  1247.       return F->ComLevel = 0;
  1248.    }  
  1249.  
  1250. /****************************** end of error.c *******************************/
  1251.  
  1252. SHAR_EOF
  1253. if test -f 'interp/except.c'
  1254. then
  1255.     echo shar: over-writing existing file "'interp/except.c'"
  1256. fi
  1257. cat << \SHAR_EOF > 'interp/except.c'
  1258.  
  1259. /****** except.c ******************************************************/
  1260. /**                                                                  **/
  1261. /**                    University of Illinois                        **/
  1262. /**                                                                  **/
  1263. /**                Department of Computer Science                    **/
  1264. /**                                                                  **/
  1265. /**   Tool: IFP                         Version: 0.5                 **/
  1266. /**                                                                  **/
  1267. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1268. /**                                                                  **/
  1269. /**   Revised by: Arch D. Robison       Date:   Dec 5, 1985          **/
  1270. /**                                                                  **/
  1271. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1272. /**                            Prof. W. J. Kubitz                    **/
  1273. /**                                                                  **/
  1274. /**                                                                  **/
  1275. /**------------------------------------------------------------------**/
  1276. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1277. /**                       All Rights Reserved.                       **/
  1278. /**********************************************************************/
  1279.  
  1280. /************************* Exception Handlers *************************/
  1281.  
  1282. #include <stdio.h>
  1283. #include "struct.h"
  1284. #include "umax.h"
  1285.  
  1286. #if OPSYS!=CTSS
  1287. #include <signal.h>
  1288. #endif
  1289.  
  1290. /*
  1291.  * There are currently two exceptions which must be dealt with.
  1292.  * 
  1293.  *    1.  Interpreter (system) errors, e.g. out of memory
  1294.  *        These are indicated by setting the variable 'SysError' to the
  1295.  *        appropriate non-zero value.  The values are listed in struct.h
  1296.  *
  1297.  *    2.  User interrupts, i.e. ctrl-C.
  1298.  *          These are counted by the variable SysStop.
  1299.  *
  1300.  *        0 = process normally
  1301.  *        1 = stop processing and print back trace
  1302.  *        2 = return to top level without printing back trace
  1303.  */
  1304. short SysError = 0;     /* An error occurred if SysError != 0 */
  1305. short SysStop = 0;
  1306.  
  1307. #if OPSYS!=CTSS
  1308. private int SetStop ()
  1309.    { 
  1310.       SysStop++; 
  1311.       (void) signal (SIGINT,SetStop);
  1312.    }
  1313. #endif OPSYS!=CTSS
  1314.  
  1315. /*
  1316.  * ResetExcept
  1317.  *
  1318.  * Reset exception handling to normal state.
  1319.  */
  1320. void ResetExcept ()
  1321.    {
  1322.       extern int UDump();
  1323.       SysError = 0;
  1324.       SysStop = 0;
  1325. #if OPSYS!=CTSS
  1326.       (void) signal (SIGINT,SetStop);
  1327. #endif
  1328. #if OPSYS==DOS
  1329.       SetCBrk ();
  1330. #endif
  1331.    }
  1332.  
  1333. SHAR_EOF
  1334. if test -f 'interp/file.c'
  1335. then
  1336.     echo shar: over-writing existing file "'interp/file.c'"
  1337. fi
  1338. cat << \SHAR_EOF > 'interp/file.c'
  1339.  
  1340. /****** file.c ********************************************************/
  1341. /**                                                                  **/
  1342. /**                    University of Illinois                        **/
  1343. /**                                                                  **/
  1344. /**                Department of Computer Science                    **/
  1345. /**                                                                  **/
  1346. /**   Tool: IFP                         Version: 0.5                 **/
  1347. /**                                                                  **/
  1348. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1349. /**                                                                  **/
  1350. /**   Revised by: Arch D. Robison       Date: June 22, 1986          **/
  1351. /**                                                                  **/
  1352. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1353. /**                            Prof. W. J. Kubitz                    **/
  1354. /**                                                                  **/
  1355. /**                                                                  **/
  1356. /**------------------------------------------------------------------**/
  1357. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1358. /**                       All Rights Reserved.                       **/
  1359. /**********************************************************************/
  1360.  
  1361.  
  1362. #include <stdio.h>
  1363. #include "struct.h"
  1364. #include "string.h"
  1365. #include "node.h"
  1366. #include "umax.h"
  1367. #include "inob.h"
  1368.  
  1369. extern char *strcpy (),*strcat (),*getenv ();
  1370.  
  1371. /*------------------------- Operating System Constants --------------------*
  1372.  *
  1373.  * Operating System Constants
  1374.  *
  1375.  * PATH_SEPARATOR = separator used for file names
  1376.  * EDITOR = path to editor
  1377.  * EdCommand = IFP command to invoke EDITOR
  1378.  *
  1379.  * Even operating systems without hierarchical file systems must
  1380.  * define a PATH_SEPARATOR, which is used still used internally.
  1381.  *
  1382.  * In the case of CTSS, we also have a constant USER_PATH.  This
  1383.  * a fictious path to the user's current directory. 
  1384.  */ 
  1385.  
  1386. #if OPSYS==UNIX
  1387. #define PATH_SEPARATOR '/'
  1388. #define EDITOR "/bin/vi"
  1389. char *EdCommand;
  1390. #endif
  1391.  
  1392. #if OPSYS==MSDOS
  1393. #define PATH_SEPARATOR '\\'
  1394. #define EDITOR "c:ed.exe"
  1395. char *EdCommand = "ed";
  1396. char DirPath [MAXPATH+1] = "c:dir.exe";
  1397. #endif
  1398.  
  1399. #if OPSYS==CTSS
  1400. #define PATH_SEPARATOR '/'
  1401. #define EDITOR "fred"
  1402. char *EdCommand = "fred";
  1403. #define USER_PATH "/usr"
  1404. #endif
  1405.  
  1406. /*-------------------- end of Operating System Constants --------------------*/
  1407.  
  1408. char RootPath [MAXPATH+1] = "";         /* Path to IFP's root */
  1409.  
  1410. char EditorPath [MAXPATH+1] = EDITOR;   /* value is default */
  1411.  
  1412. char FPprompt[16] = "ifp> ";   /* value is default */
  1413. NodePtr CurWorkDir = NULL;     /* Current working directory node */
  1414.  
  1415. /********************** Operating system file interface ***********************/
  1416.  
  1417. /*
  1418.  * PathTail
  1419.  *
  1420.  * Return the last component in a path name.
  1421.  * Returns pointer to "" if error occurs.
  1422.  */
  1423. private char *PathTail (Path)
  1424.    char *Path;
  1425.    {
  1426.       register char *T;
  1427.  
  1428.       if (*Path == PATH_SEPARATOR) Path++;
  1429.       while (*Path) {
  1430.      for (T = Path; *T++ != PATH_SEPARATOR; )
  1431.         if (!*T) return Path;
  1432.      Path = T;
  1433.       }
  1434.       return Path;
  1435.    }
  1436.  
  1437. /*------------------------------ fopen hacks ------------------------------
  1438.  *
  1439.  * Both MSDOS and CTSS have problems with hierarchical file structure.
  1440.  * Thus we have to redefine the standard UNIX function "fopen" to allow
  1441.  * for these operating system's quirks.
  1442.  */
  1443. #if OPSYS==MSDOS
  1444.  
  1445. /*
  1446.  * We try to keep track of the current directory in CWDCache so we can avoid
  1447.  * superfluous calls to chdir.  Set the 0th character to '\0' to empty the
  1448.  * cache.
  1449.  */
  1450. char CWDCache [MAXPATH] = "";
  1451.  
  1452. /*
  1453.  * PathSplit
  1454.  *
  1455.  * Split a pathname into its directory and file parts.
  1456.  * Change directory to directory part.
  1457.  *
  1458.  * Input
  1459.  *      PathName = pathname
  1460.  *
  1461.  * Output
  1462.  *      NULL if error occurs, pointer to file name otherwise.
  1463.  */
  1464. char *PathSplit (PathName)      /* also used by command.c */
  1465.    char *PathName;
  1466.    {
  1467.       register char *S,*T;
  1468.       register int R;
  1469.  
  1470.       T = PathTail (PathName);
  1471.       if (T != &PathName [1]) {
  1472.      T[-1] = '\0';
  1473.      S = PathName;          /* Break string at path separator */
  1474.       } else S = "\\";
  1475.       if (strcmp (S,CWDCache)) {
  1476.      R = chdir (S);
  1477.      if (Debug & DebugFile) printf ("cache load: %d = ChDir (%s) for %s\n",R,S,T);
  1478.      (void) strcpy (CWDCache,S);
  1479.       } else {
  1480.      if (Debug & DebugFile) printf ("cache HIT!\n"); 
  1481.      R = 0;
  1482.       }
  1483.       T[-1] = PATH_SEPARATOR;   /* Replace path separator */
  1484.       return R ? NULL : T;
  1485.    }
  1486.  
  1487. /*
  1488.  * DOSfopen
  1489.  *
  1490.  * Works as =`fopen' should.  The old Lattice C `fopen' would not take 
  1491.  * pathnames.  Even though the new compiler's will allow long names,
  1492.  * the fake fopen can take advantage of the current directory cache.
  1493.  */
  1494. private FILE *DOSfopen (FileName,Mode)
  1495.    char *FileName,*Mode;
  1496.    {
  1497.       char *T;
  1498.  
  1499.       return (T = PathSplit (FileName)) != NULL ? fopen (T,Mode) : NULL;
  1500.    }
  1501.  
  1502. #define fopen DOSfopen
  1503.  
  1504. #endif /* OPSYS==MSDOS */
  1505.  
  1506. #if OPSYS==CTSS
  1507. /*
  1508.  * CTSSfopen
  1509.  *
  1510.  * Tries for fake a real fopen.  CTSS does not support hierarchical file
  1511.  * structures, so CTSSfopen takes the tail of the path as the file name.
  1512.  */
  1513. private FILE *CTSSfopen (FileName,Mode)
  1514.    char *FileName,*Mode;
  1515.    {
  1516.       register char *T;
  1517.  
  1518.       if (Debug & DebugFile) printf ("CTSSfopen (%s,%s)\n",FileName,Mode);
  1519.       T = PathTail (FileName);
  1520.       if (T == &FileName[1]) return NULL;
  1521.       else {
  1522.      T[-1] = '\0';
  1523.      if (strcmp (FileName,USER_PATH)) return NULL;
  1524.      else {
  1525.         if (Debug & DebugFile) printf ("fopen (%s,%s)\n",T,Mode);
  1526.         return fopen (T,Mode);
  1527.      }
  1528.       }
  1529.    }
  1530. #define fopen CTSSfopen
  1531.  
  1532. #endif /* OPSYS==CTSS */
  1533.  
  1534. /*---------------------------- end of fopen hacks ----------------------------*/
  1535.  
  1536. /*
  1537.  * FormNPath
  1538.  *
  1539.  * Create the pathname for a given node.
  1540.  *
  1541.  * Input
  1542.  *      N = pointer to node
  1543.  *      PathLim = pointer to end of PathName buffer
  1544.  *
  1545.  * Output
  1546.  *      Pathname for node
  1547.  */
  1548. char *FormNPath (N,PathName,PathLim)
  1549.    register NodePtr N;
  1550.    char PathName[];
  1551.    register char *PathLim;
  1552.    {
  1553.       CharPtr U;
  1554.       register char *T;
  1555.  
  1556.       if (N->NodeParent == NULL) {
  1557.      (void) strcpy (PathName,RootPath);
  1558.      return &PathName [strlen (PathName)];
  1559.       } else {
  1560.      T = FormNPath (N->NodeParent,PathName,PathLim);
  1561.      if (T==NULL) return NULL;
  1562.      else {
  1563.         *T++ = PATH_SEPARATOR;
  1564.         CPInit (&U,&N->NodeName);
  1565.         (void) CPRead (&U,T,PathLim-T);
  1566. #if OPSYS==UNIX
  1567.         T += strlen (T);
  1568. #endif
  1569. #if OPSYS==MSDOS || OPSYS==CTSS 
  1570.         /* DOS and CTSS names limited to 8 characters */
  1571.         {
  1572.            int L;               
  1573.            if ((L = strlen (T)) > 8) L = 8;
  1574.            *(T += L) = '\0';
  1575.         }
  1576. #endif
  1577.         if (!CPRead (&U,T,PathLim-T)) return T;
  1578.         else return NULL; /* U should be empty */
  1579.      }
  1580.       }
  1581.    }
  1582.  
  1583.  
  1584. /*
  1585.  * FormPath
  1586.  *
  1587.  * Make UNIX or DOS pathname for node
  1588.  *
  1589.  * Input
  1590.  *      N = node or path list
  1591.  *      PathName = buffer to put pathname in.
  1592.  *      PathLim = pointer to end of buffer
  1593.  *
  1594.  * Output
  1595.  *      PathName = pathname if successful
  1596.  */
  1597. void FormPath (N,PathName,PathLim)
  1598.    register ObjectPtr N;
  1599.    char PathName[];
  1600.    char *PathLim;
  1601.    {
  1602.       register char *T;
  1603.       CharPtr U;
  1604.       register ListPtr P;
  1605.       register int K;
  1606.  
  1607.       switch (N->Tag) {
  1608.  
  1609.      case LIST:
  1610.         (void) strcpy (PathName,RootPath);
  1611.         K = strlen (PathName);
  1612.         PathLim -= K;
  1613.         T = &PathName [K];
  1614.         for (P = N->List; P!=NULL; P=P->Next) {
  1615.            if (P->Val.Tag != STRING) return;
  1616.            else {
  1617.           CPInit (&U,&P->Val.String);
  1618.           (void) CPRead (&U,T,PathLim-PathName);
  1619. #if OPSYS==UNIX
  1620.           T += strlen (T);
  1621. #endif
  1622. #if OPSYS==MSDOS || OPSYS==CTSS 
  1623.           /* DOS names are limited to 8 characters */
  1624.           if ((K = strlen (T)) > 8) K = 8; 
  1625.           *(T += K) = '\0';
  1626. #endif
  1627.           /* T should always be <= PathLim */
  1628.           if (T >= PathLim) return;
  1629.            }
  1630.         }
  1631.         break;
  1632.  
  1633.      case NODE:
  1634.         (void) FormNPath (N->Node,PathName,PathLim);
  1635.         break;
  1636.  
  1637.      default:
  1638.         break;
  1639.       }
  1640.    }
  1641.  
  1642. /*
  1643.  * ReadDef
  1644.  *
  1645.  * Read a definition node.  The definition node tag must be BOTTOM upon entry
  1646.  * when running UMAX.
  1647.  *
  1648.  * Input
  1649.  *      Caller = pointer to DEF node of caller
  1650.  *      Fun = object with tag NODE.  
  1651.  */
  1652. void ReadDef (Caller,Fun)
  1653.    NodePtr Caller;
  1654.    ObjectPtr Fun;
  1655.    {
  1656.       NodePtr N;
  1657.       char FileName[MAXPATH];
  1658.       FILE *DefFile;
  1659.       InDesc F;
  1660.       int C;
  1661.  
  1662.  
  1663.       if (NULL == FormNPath (N=Fun->Node,FileName,&FileName[MAXPATH])) 
  1664.      DefError (Caller,Fun,"invalid name for function");
  1665.       else 
  1666.      while (NULL != (DefFile = fopen (FileName,"r"))) {
  1667.         InitIn (&F,N->NodeParent,DefFile,0);
  1668.         C = InDef (&F,N->NodeName,&N->NodeData.NodeDef.DefCode);
  1669.         (void) fclose (F.InFile);
  1670.         if (C) goto exit;
  1671.         printf ("Do you wish to edit %s ? ",FileName + strlen (RootPath));
  1672.         while (1) {
  1673.            for (C = getchar (); getchar ()!='\n';) continue;
  1674.            if (C == 'y') {
  1675.           ExecEdit (FileName); 
  1676.           break;
  1677.            }
  1678.            if (C == 'n') goto exit;
  1679.            printf ("Respond with y or n\n");
  1680.         }
  1681.      } 
  1682. exit:;
  1683.    }
  1684.  
  1685. /*
  1686.  * ReadImport
  1687.  *
  1688.  * Read the import file for a module node.
  1689.  *
  1690.  * Input
  1691.  *      M = pointer to module node
  1692.  */
  1693. void ReadImport (M)
  1694.    NodePtr M;
  1695.    {
  1696.       char *T;
  1697.       char FileName[MAXPATH];
  1698.       FILE *ImpFile;
  1699.       InDesc F;
  1700.  
  1701.       if (NULL != (T = FormNPath (M,FileName,&FileName[MAXPATH]))) {
  1702.      *T++ = PATH_SEPARATOR;
  1703.      (void) strcpy (T,"%IMPORT");
  1704.      if (NULL != (ImpFile = fopen (FileName,"r"))) {
  1705.         InitIn (&F,M,ImpFile,0);
  1706.         InImport (&F,M);
  1707.         (void) fclose (ImpFile);
  1708.      }
  1709.       }
  1710.    }
  1711.  
  1712. #if OPSYS!=CTSS
  1713. /*
  1714.  * EnvGet
  1715.  *
  1716.  * Get value for environment variable.
  1717.  *
  1718.  * Input
  1719.  *      Key = enviroment variable name
  1720.  *      Value = default value for variable
  1721.  *      ValLim = length of Value buffer
  1722.  *
  1723.  * Output
  1724.  *      Value = value of enviroment variable, or default if not found.
  1725.  */
  1726. void EnvGet (Key,Value,ValLim)
  1727.    char *Key,*Value;
  1728.    int ValLim;
  1729.    {
  1730.       char *V;
  1731.  
  1732.       V = getenv (Key);
  1733.       if (V != NULL)
  1734.      if (strlen (V) < ValLim) (void) strcpy (Value,V);
  1735.      else fprintf (stderr,"Error: %s in enviroment is longer than %d\n",
  1736.                Key,MAXPATH-3);
  1737.    }
  1738.  
  1739.  
  1740. /*
  1741.  * CWDGet
  1742.  *
  1743.  * Find pathname of current working directory (relative to FP root).
  1744.  *
  1745.  * Input
  1746.  *      PathLim = length of Path buffer (used by PCAT versions only)
  1747.  *
  1748.  * Output
  1749.  *      result = 1 if valid FP path, 0 otherwise
  1750.  *      Path = FP pathname if valid, undefined otherwise
  1751.  */
  1752. boolean CWDGet (Path,PathLim)
  1753.    register char *Path;
  1754.    int PathLim;
  1755.    {
  1756. #ifdef PCAT
  1757.       extern char *getcwd ();
  1758.       if (!getcwd (Path,PathLim-2)) return 0;
  1759. #else
  1760. #if S9000
  1761.       extern FILE *popen ();
  1762.       FILE *F;                          /* S9000 Xenix has no getwd! */
  1763.       F = popen ("/bin/pwd","r");
  1764.       fscanf (F,"%s",Path);
  1765.       pclose (F);
  1766. #else
  1767.       extern char *getwd();
  1768.       if (!getwd (Path)) return 0;
  1769. #endif /* S9000 */
  1770. #endif /* PCAT */
  1771.  
  1772. #if OPSYS==MSDOS
  1773.       (void) strcpy (Path,Path+2);              /* Delete drive name */
  1774.       if (Debug & DebugFile) printf ("CWD = '%s'\n",Path); 
  1775.       return 1;
  1776. #endif
  1777. #if OPSYS==UNIX
  1778.       {
  1779.      register int K;
  1780.      K = strlen (RootPath);
  1781.      if (strncmp (Path,RootPath,K)) return 0;
  1782.      else {
  1783.         (void) strcpy (Path,&Path[K]);    /* Remove FP root path prefix */
  1784.         return 1;
  1785.      }
  1786.       }
  1787. #endif
  1788.    }
  1789. #endif /* OPSYS != CTSS */
  1790.  
  1791. /*
  1792.  * InitFile
  1793.  *
  1794.  * The DOS version is kludgy.  The problem is that DOSfopen changes 
  1795.  * the current directory, thus munging it before CWDGet is called.
  1796.  */
  1797. #if OPSYS==UNIX || OPSYS==CTSS
  1798. void InitFile ()
  1799. #endif
  1800. #if OPSYS==MSDOS
  1801. void InitFile (CWD)
  1802.    char *CWD;
  1803. #endif
  1804.    {
  1805.       Object X;
  1806.       InDesc F;
  1807.  
  1808.       if (Debug & DebugFile) printf ("enter InitFile\n");
  1809. #if OPSYS!=CTSS
  1810.       EnvGet ("EDITOR",EditorPath,MAXPATH);
  1811. #endif
  1812.       if (Debug & DebugFile) printf ("EditorPath = `%s'\n",EditorPath);
  1813. #if OPSYS==UNIX
  1814.       EdCommand = PathTail (EditorPath);
  1815.       if (!*EdCommand) {
  1816.      fprintf (stderr,"\n * EDITOR environment variable not a full path.");
  1817.      fprintf (stderr,"\n   Setting editor to '%s'.\n",EDITOR);
  1818.      EdCommand = PathTail (strcpy (EditorPath,EDITOR));
  1819.       }
  1820.       EnvGet ("IFPprompt",FPprompt,sizeof (FPprompt));
  1821. #endif
  1822. #if OPSYS==MSDOS
  1823.       EnvGet ("IFPDIR",DirPath,MAXPATH);
  1824.       if (Debug & DebugFile) printf ("IFPDIR = '%s'\n",DirPath);
  1825. #endif
  1826.  
  1827.       /* Create dummy descriptor for scanning environment info */
  1828.       InitIn (&F,(NodePtr) NULL,(FILE *) NULL, -1); 
  1829.  
  1830. #if OPSYS==UNIX
  1831.       if (!CWDGet (F.InBuf,INBUFSIZE-1)) {
  1832.      fprintf (stderr,"\n\n * Current directory not a IFP subdirectory.");
  1833.      fprintf (stderr,  "\n   Setting current directory to IFP root.\n");
  1834.      if (chdir (RootPath)) {
  1835.         extern int errno;
  1836.         perror (RootPath);
  1837.         exit (errno);
  1838.      } else F.InBuf[0] = '\0';
  1839.       }
  1840. #endif
  1841. #if OPSYS==MSDOS
  1842.       {
  1843.      register char *T;
  1844.      (void) strcpy (F.InBuf,CWD);
  1845.      for (T=F.InBuf; *T; T++)
  1846.         if (*T == PATH_SEPARATOR) *T = '/';
  1847.       }
  1848. #endif
  1849. #if OPSYS==CTSS
  1850.       (void) strcpy (F.InBuf,USER_PATH);
  1851. #endif
  1852.       if (F.InBuf[0]) {
  1853.      (void) strcat (F.InPtr,"\n");
  1854.      (void) InNode (&F,&X,NIL);
  1855.      CurWorkDir = MakeNode (X.List,1);
  1856.       } else 
  1857.      CurWorkDir = RootNode;
  1858.       if (Debug & DebugFile) printf ("exit InitFile\n");
  1859.    }
  1860.  
  1861.  
  1862. /************************* end of file.c *******************************/
  1863.  
  1864. SHAR_EOF
  1865. if test -f 'interp/forms.c'
  1866. then
  1867.     echo shar: over-writing existing file "'interp/forms.c'"
  1868. fi
  1869. cat << \SHAR_EOF > 'interp/forms.c'
  1870.  
  1871. /****** forms.c *******************************************************/
  1872. /**                                                                  **/
  1873. /**                    University of Illinois                        **/
  1874. /**                                                                  **/
  1875. /**                Department of Computer Science                    **/
  1876. /**                                                                  **/
  1877. /**   Tool: IFP                         Version: 0.5                 **/
  1878. /**                                                                  **/
  1879. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1880. /**                                                                  **/
  1881. /**   Revised by: Arch D. Robison       Date: July 28, 1986          **/
  1882. /**                                                                  **/
  1883. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1884. /**                            Prof. W. J. Kubitz                    **/
  1885. /**                                                                  **/
  1886. /**                                                                  **/
  1887. /**------------------------------------------------------------------**/
  1888. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1889. /**                       All Rights Reserved.                       **/
  1890. /**********************************************************************/
  1891.  
  1892. #include "struct.h"
  1893. #include "node.h"
  1894. #include "umax.h"
  1895. #include "stats.h"
  1896. #include <stdio.h>
  1897.  
  1898. /*
  1899.  * FF_Each
  1900.  *
  1901.  * Apply function F to each element of list InOut
  1902.  *
  1903.  * Input
  1904.  *      InOut = list of elements to apply function
  1905.  *      Funs = singleton list of function to be applied
  1906.  *
  1907.  * Output
  1908.  *      InOut = result
  1909.  */
  1910. private FF_Each (InOut,Funs)
  1911.    ObjectPtr InOut;
  1912.    register ListPtr Funs;
  1913.    {
  1914.       register ListPtr P;
  1915.  
  1916.       switch (InOut->Tag) {
  1917.      default:
  1918.         FormError (InOut,ArgNotSeq,NODE_Each,Funs);
  1919.         return;
  1920.      case LIST:
  1921.         CopyTop (&InOut->List);
  1922.         break;
  1923.       }
  1924.       for (P = InOut->List; P!=NULL; P=P->Next) {
  1925.      Apply (&P->Val,&Funs->Val);
  1926.      if (P->Val.Tag == BOTTOM) {
  1927.         RepTag (InOut,BOTTOM);      /* Error already reported */
  1928.         return;
  1929.      }
  1930.       }
  1931.    }
  1932.  
  1933.  
  1934. /*
  1935.  * FF_Filter
  1936.  *
  1937.  * Input
  1938.  *      InOut = list of elements to apply predicate
  1939.  *      Funs = singleton list of function to be applied
  1940.  *
  1941.  * Output
  1942.  *      InOut = result - list of element for which predicate is true.
  1943.  */
  1944. private FF_Filter (InOut,Funs)
  1945.    register ObjectPtr InOut;
  1946.    register ListPtr Funs;
  1947.    {
  1948.       register ListPtr P;
  1949.       register MetaPtr E;
  1950.       ListPtr Result;
  1951.       Object X;
  1952.  
  1953.       if (InOut->Tag != LIST)
  1954.      FormError (InOut,ArgNotSeq,NODE_Filter,Funs);
  1955.       else {
  1956.      Result = NULL;
  1957.      E = &Result;
  1958.      for (P = InOut->List; P!=NULL; P=P->Next) {
  1959.         CopyObject (&X,&P->Val);
  1960.         Apply (&X,&Funs->Val);
  1961.         if (X.Tag != BOOLEAN) {
  1962.            FormError (&X,"non-boolean predicate",NODE_Filter,Funs);
  1963.            RepTag (InOut,BOTTOM);
  1964.            DelLPtr (Result);
  1965.            return;
  1966.         } else if (X.Bool) {   /* append element to result list */
  1967.            NewList (E,1L);
  1968.            CopyObject (&(*E)->Val,&P->Val);
  1969.            E = &(*E)->Next;
  1970.         }
  1971.      }
  1972.      DelLPtr (InOut->List);
  1973.      InOut->List = Result;
  1974.       }
  1975.    }
  1976.  
  1977.  
  1978. /*
  1979.  * FF_Compose
  1980.  *
  1981.  * Function composition
  1982.  *
  1983.  * Input
  1984.  *      InOut = object to apply composition
  1985.  *      Funs = list of functions to compose in reverse order
  1986.  *
  1987.  * Output
  1988.  *      InOut = result of composition
  1989.  */
  1990. private FF_Compose (InOut,Funs)
  1991.    register ObjectPtr InOut;
  1992.    register ListPtr Funs;
  1993.    {
  1994.       for (; Funs != NULL && InOut->Tag != BOTTOM; Funs = Funs->Next)
  1995.      Apply (InOut,&Funs->Val);
  1996.    }
  1997.  
  1998. /*
  1999.  * FF_RInsert
  2000.  *
  2001.  * Function right insert
  2002.  */
  2003. private FF_RInsert (InOut,Funs)
  2004.    register ObjectPtr InOut;
  2005.    register ListPtr Funs;
  2006.    {
  2007.       ListPtr Terms;
  2008.  
  2009.       if (InOut->Tag != LIST)
  2010.      FormError (InOut,ArgNotSeq,NODE_RInsert,Funs);
  2011.       else if (InOut->List == NULL) 
  2012.      FormError (InOut,"empty sequence",NODE_RInsert,Funs);
  2013.       else {
  2014.      F_Reverse (InOut); /* Copy top and reverse */
  2015.      Terms = InOut->List->Next;
  2016.      InOut->List->Next = NULL;
  2017.      RepObject (InOut,&InOut->List->Val);
  2018.      while (Terms != NULL) {
  2019.         /* form pair and apply function */
  2020.         NewList (&Terms->Next,1L);
  2021.         Terms->Next->Val.Tag = InOut->Tag;
  2022.         Terms->Next->Val.Data = InOut->Data;
  2023.         InOut->Tag = LIST;
  2024.         InOut->List = NULL;
  2025.         Rot3 (&InOut->List,&Terms,&Terms->Next->Next);
  2026.         Apply (InOut,&Funs->Val);
  2027.         if (InOut->Tag == BOTTOM) {
  2028.            DelLPtr (Terms);
  2029.            break;
  2030.         }
  2031.      }
  2032.       }
  2033.    }
  2034.  
  2035. /*
  2036.  * FF_C
  2037.  *
  2038.  * Constant function
  2039.  */
  2040. private FF_C (InOut,Funs)
  2041.    ObjectPtr InOut;
  2042.    register ListPtr Funs;
  2043.    {
  2044.       Stat (StatConstant (InOut));
  2045.       if (Funs == NULL) 
  2046.      FormError (InOut,"(constant bottom)",NODE_C,Funs);
  2047.       else 
  2048.      RepObject (InOut,&Funs->Val);
  2049.    }
  2050.  
  2051. /*
  2052.  * FF_Out
  2053.  *
  2054.  * Print debugging message
  2055.  */
  2056. private FF_Out (InOut,Funs)
  2057.    ObjectPtr InOut;
  2058.    register ListPtr Funs;
  2059.    {
  2060.       LineWait ();
  2061.       OutObject (&Funs->Val),
  2062.       printf (": "),
  2063.       OutObject (InOut),
  2064.       printf ("\n");
  2065.       LineSignal ();
  2066.    }
  2067.  
  2068.  
  2069. #if FETCH 
  2070. /*
  2071.  * FF_Fetch
  2072.  *
  2073.  * Fetch form
  2074.  */
  2075. private FF_Fetch (InOut,Funs)
  2076.    ObjectPtr InOut;
  2077.    register ListPtr Funs;
  2078.    {
  2079.       register ListPtr P,Q,R;
  2080.  
  2081.       if (InOut->Tag != LIST)
  2082.      FormError (InOut,ArgNotSeq,NODE_Fetch,Funs);
  2083.       else {
  2084.      R = NULL;
  2085.  
  2086.      for (P = InOut->List; P != NULL; P=P->Next)
  2087.         if (P->Val.Tag != LIST || (Q=P->Val.List) == NULL ||
  2088.         Q->Next == NULL || Q->Next->Next != NULL) {
  2089.            FormError (InOut,"element not a pair",NODE_Fetch,Funs);
  2090.            return;
  2091.         } else
  2092.            if (R == NULL && ObEqual (&Q->Val,&Funs->Val)) R = Q;
  2093.  
  2094.      if (R!=NULL) RepObject (InOut,&R->Next->Val);
  2095.      else FormError (InOut,"key not found",NODE_Fetch,Funs);
  2096.      return;
  2097.  
  2098.       }
  2099.    }
  2100. #endif FETCH
  2101.  
  2102.  
  2103. /*
  2104.  * FF_If
  2105.  *
  2106.  * Conditional p->f;g
  2107.  *
  2108.  * Input
  2109.  *      InOut = object to apply conditional
  2110.  *      Funs = <p f g>
  2111.  *
  2112.  * Output
  2113.  *      InOut = result of conditional
  2114.  */
  2115. private FF_If (InOut,Funs)
  2116.    ObjectPtr InOut;
  2117.    ListPtr Funs;
  2118.    {
  2119.       Object P;
  2120.  
  2121.       CopyObject (&P,InOut);
  2122.       Apply (&P,&Funs->Val);
  2123.       if (P.Tag == BOOLEAN) 
  2124.      Apply (InOut, & (P.Bool ? Funs : Funs->Next)->Next->Val);
  2125.       else {
  2126.      FormError (&P,"non-boolean predicate",NODE_If,Funs);
  2127.      RepTag (InOut,BOTTOM);
  2128.       } 
  2129.    }
  2130.  
  2131. /*
  2132.  * FF_Construct
  2133.  *
  2134.  * Function construction
  2135.  *
  2136.  * Input
  2137.  *      InOut = object to apply construction
  2138.  *      Funs = list of functions to construct
  2139.  *
  2140.  * Output
  2141.  *      InOut = result
  2142.  */
  2143. private FF_Construct (InOut,Funs)
  2144.    register ObjectPtr InOut;
  2145.    ListPtr Funs;
  2146.    {
  2147.       register ListPtr P,F;
  2148.       Stat (StatConstruct (Funs));
  2149.       P = Repeat (InOut, ListLength (F = Funs));
  2150.       if (SysError) return;
  2151.       RepTag (InOut,LIST);
  2152.       for (InOut->List = P; F != NULL; P=P->Next,F=F->Next) {
  2153.      Apply (& P->Val,& F->Val);
  2154.      if (P->Val.Tag == BOTTOM) {
  2155.         RepTag (InOut,BOTTOM);     /* Error was already reported */
  2156.         return;
  2157.          }
  2158.       }
  2159.    }
  2160.  
  2161.  
  2162. /*
  2163.  * FF_Select
  2164.  *
  2165.  * Selector form (e.g. 1,2r)
  2166.  *
  2167.  * Input
  2168.  *      InOut = object
  2169.  *      Funs = index parameter list - positive values are left selectors
  2170.  *                                    negative values are right selectors
  2171.  */
  2172. private FF_Select (InOut,Funs)
  2173.    ObjectPtr InOut;
  2174.    ListPtr Funs;
  2175.    {
  2176.       register ListPtr P;
  2177.       register long N;
  2178.       char *E;
  2179.  
  2180.       N = Funs->Val.Int; 
  2181.       switch (InOut->Tag) {
  2182.      default:
  2183.         E = ArgNotSeq;
  2184.         break;
  2185.      case NODE:
  2186.         NodeExpand (InOut);
  2187.  
  2188.      case LIST:
  2189.         P = InOut->List;
  2190.         if (N < 0) N += ListLength (P) + 1;
  2191.         if (--N >= 0) {
  2192.            for (; P!=NULL; P=P->Next)
  2193.           if (--N < 0) {
  2194.              RepObject (InOut,&P->Val);
  2195.              return;
  2196.           }
  2197.            E = "index off right end";
  2198.         } else
  2199.            E = "index off left end";
  2200.         break;
  2201.       }
  2202.       FormError (InOut,E,NODE_Sel,Funs);
  2203.    }
  2204.  
  2205.  
  2206. /*
  2207.  * FF_While
  2208.  *
  2209.  * While P is true, apply F to X
  2210.  *
  2211.  * Input
  2212.  *      InOut = X
  2213.  *      Funs = pair <P F>
  2214.  *
  2215.  * Output
  2216.  *      InOut = result
  2217.  */
  2218. private FF_While (InOut,Funs)
  2219.    register ObjectPtr InOut;
  2220.    register ListPtr Funs;
  2221.    {
  2222.       Object P;
  2223.  
  2224.       P.Tag = BOTTOM;
  2225.       while (InOut->Tag!=BOTTOM) {
  2226.      CopyObject (&P,InOut);       /* old P was element of {?,f,t} */
  2227.      Apply (&P,&Funs->Val);
  2228.      if (P.Tag != BOOLEAN) {
  2229.         FormError (&P,"non-boolean predicate",NODE_While,Funs);
  2230.         RepTag (InOut,BOTTOM);
  2231.      } else
  2232.         if (P.Bool) Apply (InOut,&Funs->Next->Val);
  2233.         else break;
  2234.       }
  2235.    }
  2236.  
  2237.  
  2238. #if XDEF
  2239. extern FF_XDef();
  2240. #endif
  2241.  
  2242. /*
  2243.  * FormTable
  2244.  *
  2245.  * These entries must be ordered to correspond with the #defines in "node.h".
  2246.  */
  2247. FormEntry FormTable[] = {
  2248.    {NULL, "#",      {"constant" ,-1,FF_C        }, "#c"},
  2249.    {NULL, "",       {"compose"  ,-1,FF_Compose  }, ""},
  2250.    {NULL, "[",      {"construct",-1,FF_Construct}, "[...]"},
  2251.    {NULL, "EACH",   {"each"     , 1,FF_Each     }, "EACH g END"},
  2252. #if FETCH
  2253.    {NULL, "^",      {"fetch"    , 1,FF_Fetch    }, "^c"},
  2254. #endif
  2255.    {NULL, "FILTER", {"filter"   , 1,FF_Filter   }, "FILTER p END"},
  2256.    {NULL, "IF",     {"if"       , 3,FF_If       }, "IF p THEN g ELSE h END"},
  2257.    {NULL, "INSERT", {"insertr"  , 1,FF_RInsert  }, "INSERT g END"},
  2258.    {NULL, "@",      {"out"      , 1,FF_Out      }, "@message"},
  2259.    {NULL, "",       {"select"   , 1,FF_Select   }, "digit"},
  2260.    {NULL, "WHILE",  {"while"    , 2,FF_While    }, "WHILE p DO g END"}
  2261. #if XDEF
  2262.   ,{NULL, "{",      {"xdef"     , 3,FF_XDef     }, "{...}"},
  2263. #endif
  2264. };
  2265.  
  2266. void D_form ()
  2267.    {
  2268.       FormEntry *N;
  2269.  
  2270.       for (N=FormTable; N<ArrayEnd (FormTable); N++) 
  2271.      N->FormNode = PrimDef (N->FormOp.OpPtr,
  2272.                 N->FormOp.OpName,
  2273.                 SysNode,
  2274.                 N->FormOp.OpParam);
  2275.    }
  2276.  
  2277. /******************************* end of forms.c *******************************/
  2278.  
  2279. SHAR_EOF
  2280. #    End of shell archive
  2281. exit 0
  2282.  
  2283. -- 
  2284.  
  2285. Rich $alz            "Anger is an energy"
  2286. Cronus Project, BBN Labs    rsalz@pineapple.bbn.com
  2287. Moderator, comp.sources.unix    sources@uunet.uu.net
  2288.